home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / strsrch.scm < prev    next >
Text File  |  1999-04-19  |  5KB  |  147 lines
  1. ;;; "MISCIO" Search for string from port.
  2. ; Written 1995, 1996 by Oleg Kiselyov (oleg@ponder.csci.unt.edu)
  3. ; Modified 1996, 1997, 1998 by A. Jaffer (jaffer@ai.mit.edu)
  4. ;
  5. ; This code is in the public domain.
  6.  
  7. ;;; Return the index of the first occurence of a-char in str, or #f
  8. (define (string-index str a-char)
  9.   (let loop ((pos 0))
  10.     (cond
  11.      ;; whole string has been searched, in vain
  12.      ((>= pos (string-length str)) #f)
  13.      ((char=? a-char (string-ref str pos)) pos)
  14.      (else (loop (+ 1 pos))))))
  15.  
  16. (define (string-index-ci str a-char)
  17.   (let loop ((pos 0))
  18.     (cond
  19.      ;; whole string has been searched, in vain
  20.      ((>= pos (string-length str)) #f)
  21.      ((char-ci=? a-char (string-ref str pos)) pos)
  22.      (else (loop (+ 1 pos))))))
  23.  
  24. (define (string-reverse-index str a-char)
  25.   (let loop ((pos (- (string-length str) 1)))
  26.     (cond ((< pos 0) #f)
  27.       ((char=? (string-ref str pos) a-char) pos)
  28.       (else (loop (- pos 1))))))
  29.  
  30. (define (string-reverse-index-ci str a-char)
  31.   (let loop ((pos (- (string-length str) 1)))
  32.     (cond ((< pos 0) #f)
  33.       ((char-ci=? (string-ref str pos) a-char) pos)
  34.       (else (loop (- pos 1))))))
  35.  
  36. (define (miscio:substring? pattern str char=?)
  37.   (let* ((pat-len (string-length pattern))
  38.      (search-span (- (string-length str) pat-len))
  39.      (c1 (if (zero? pat-len) #f (string-ref pattern 0)))
  40.      (c2 (if (<= pat-len 1) #f (string-ref pattern 1))))
  41.     (cond
  42.      ((not c1) 0)            ; empty pattern, matches upfront
  43.      ((not c2) (string-index str c1))    ; one-char pattern
  44.      (else                ; matching pattern of > two chars
  45.       (let outer ((pos 0))
  46.     (cond
  47.      ((> pos search-span) #f)    ; nothing was found thru the whole str
  48.      ((not (char=? c1 (string-ref str pos)))
  49.       (outer (+ 1 pos)))        ; keep looking for the right beginning
  50.      ((not (char=? c2 (string-ref str (+ 1 pos))))
  51.       (outer (+ 1 pos)))        ; could've done pos+2 if c1 == c2....
  52.      (else                ; two char matched: high probability
  53.                     ; the rest will match too
  54.       (let inner ((i-pat 2) (i-str (+ 2 pos)))
  55.         (if (>= i-pat pat-len) pos    ; the whole pattern matched
  56.         (if (char=? (string-ref pattern i-pat)
  57.                 (string-ref str i-str))
  58.             (inner (+ 1 i-pat) (+ 1 i-str))
  59.             ;; mismatch after partial match
  60.             (outer (+ 1 pos))))))))))))
  61.  
  62. (define (substring? pattern str) (miscio:substring? pattern str char=?))
  63. (define (substring-ci? pattern str) (miscio:substring? pattern str char-ci=?))
  64.  
  65. (define (find-string-from-port? str <input-port> . max-no-char)
  66.   (set! max-no-char (if (null? max-no-char) #f (car max-no-char)))
  67.   (letrec
  68.       ((no-chars-read 0)
  69.        (peeked? #f)
  70.        (my-peek-char            ; Return a peeked char or #f
  71.     (lambda () (and (or (not (number? max-no-char))
  72.                 (< no-chars-read max-no-char))
  73.             (let ((c (peek-char <input-port>)))
  74.               (cond (peeked? c)
  75.                 ((eof-object? c) #f)
  76.                 ((procedure? max-no-char)
  77.                  (set! peeked? #t)
  78.                  (if (max-no-char c) #f c))
  79.                 ((eqv? max-no-char c) #f)
  80.                 (else c))))))
  81.        (next-char (lambda () (set! peeked? #f) (read-char <input-port>)
  82.               (set! no-chars-read  (+ 1 no-chars-read))))
  83.        (match-1st-char            ; of the string str
  84.     (lambda ()
  85.       (let ((c (my-peek-char)))
  86.         (and c
  87.          (begin (next-char)
  88.             (if (char=? c (string-ref str 0))
  89.                 (match-other-chars 1)
  90.                 (match-1st-char)))))))
  91.        ;; There has been a partial match, up to the point pos-to-match
  92.        ;; (for example, str[0] has been found in the stream)
  93.        ;; Now look to see if str[pos-to-match] for would be found, too
  94.        (match-other-chars
  95.     (lambda (pos-to-match)
  96.       (if (>= pos-to-match (string-length str))
  97.           no-chars-read        ; the entire string has matched
  98.           (let ((c (my-peek-char)))
  99.         (and c
  100.              (if (not (char=? c (string-ref str pos-to-match)))
  101.              (backtrack 1 pos-to-match)
  102.              (begin (next-char)
  103.                 (match-other-chars (+ 1 pos-to-match)))))))))
  104.  
  105.        ;; There had been a partial match, but then a wrong char showed up.
  106.        ;; Before discarding previously read (and matched) characters, we check
  107.        ;; to see if there was some smaller partial match. Note, characters read
  108.        ;; so far (which matter) are those of str[0..matched-substr-len - 1]
  109.        ;; In other words, we will check to see if there is such i>0 that
  110.        ;; substr(str,0,j) = substr(str,i,matched-substr-len)
  111.        ;; where j=matched-substr-len - i
  112.        (backtrack
  113.     (lambda (i matched-substr-len)
  114.       (let ((j (- matched-substr-len i)))
  115.         (if (<= j 0)
  116.         ;; backed off completely to the begining of str
  117.         (match-1st-char)
  118.         (let loop ((k 0))
  119.           (if (>= k j)
  120.               (match-other-chars j) ; there was indeed a shorter match
  121.               (if (char=? (string-ref str k)
  122.                   (string-ref str (+ i k)))
  123.               (loop (+ 1 k))
  124.               (backtrack (+ 1 i) matched-substr-len))))))))
  125.        )
  126.     (match-1st-char)))
  127.  
  128. (define (string-subst text old new . rest)
  129.   (define sub
  130.     (lambda (text)
  131.       (set! text
  132.         (cond ((equal? "" text) text)
  133.           ((substring? old text)
  134.            => (lambda (idx)
  135.             (string-append
  136.              (substring text 0 idx)
  137.              new
  138.              (sub (substring
  139.                    text (+ idx (string-length old))
  140.                    (string-length text))))))
  141.           (else text)))
  142.       (if (null? rest)
  143.       text
  144.       (apply string-subst text rest))))
  145.   (sub text))
  146.  
  147.